home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / wttree.scm < prev    next >
Text File  |  1999-04-19  |  28KB  |  791 lines
  1. ;;  "wttree.scm" Weight balanced trees            -*-Scheme-*-
  2. ;;  Copyright (c) 1993-1994 Stephen Adams
  3. ;;
  4. ;;  $Id: wttree.scm,v 1.2 1998/02/09 23:13:10 jaffer Exp $
  5. ;;
  6. ;;  References:
  7. ;;
  8. ;;    Stephen Adams, Implemeting Sets Efficiently in a Functional
  9. ;;       Language, CSTR 92-10, Department of Electronics and Computer
  10. ;;       Science, University of Southampton, 1992
  11. ;;
  12. ;;
  13. ;;  Copyright (c) 1993-94 Massachusetts Institute of Technology
  14. ;;
  15. ;;  This material was developed by the Scheme project at the Massachusetts
  16. ;;  Institute of Technology, Department of Electrical Engineering and
  17. ;;  Computer Science.  Permission to copy this software, to redistribute
  18. ;;  it, and to use it for any purpose is granted, subject to the following
  19. ;;  restrictions and understandings.
  20. ;;
  21. ;;  1. Any copy made of this software must include this copyright notice
  22. ;;  in full.
  23. ;;
  24. ;;  2. Users of this software agree to make their best efforts (a) to
  25. ;;  return to the MIT Scheme project any improvements or extensions that
  26. ;;  they make, so that these may be included in future releases; and (b)
  27. ;;  to inform MIT of noteworthy uses of this software.
  28. ;;
  29. ;;  3. All materials developed as a consequence of the use of this
  30. ;;  software shall duly acknowledge such use, in accordance with the usual
  31. ;;  standards of acknowledging credit in academic research.
  32. ;;
  33. ;;  4. MIT has made no warrantee or representation that the operation of
  34. ;;  this software will be error-free, and MIT is under no obligation to
  35. ;;  provide any services, by way of maintenance, update, or otherwise.
  36. ;;
  37. ;;  5. In conjunction with products arising from the use of this material,
  38. ;;  there shall be no use of the name of the Massachusetts Institute of
  39. ;;  Technology nor of any adaptation thereof in any advertising,
  40. ;;  promotional, or sales literature without prior written consent from
  41. ;;  MIT in each case.
  42.  
  43. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  44. ;;
  45. ;;  Weight Balanced Binary Trees
  46. ;;
  47. ;;  
  48. ;;
  49. ;;  This file has been modified from the MIT-Scheme library version to
  50. ;;  make it more standard. The main changes are
  51. ;;
  52. ;;   . The whole thing has been put in a LET as R4RS Scheme has no module
  53. ;;     system.
  54. ;;   . The MIT-Scheme define structure operations have been written out by
  55. ;;     hand.
  56. ;;
  57. ;;  It has been tested on MIT-Scheme, scheme48 and scm4e1
  58. ;;
  59. ;;  If your system has a compiler and you want this code to run fast, you
  60. ;;  should do whatever is necessary to inline all of the structure accessors.
  61. ;;
  62. ;;  This is MIT-Scheme's way of saying that +, car etc should all be inlined.
  63. ;;
  64. ;;(declare (usual-integrations))
  65.  
  66. (define error
  67.   (case (scheme-implementation-type)
  68.     ((MITScheme) error)
  69.     (else slib:error)))
  70. (define error:wrong-type-argument
  71.   (case (scheme-implementation-type)
  72.     ((MITScheme) error:wrong-type-argument)
  73.     (else (lambda (arg1 arg2 arg3)
  74.         (slib:error 'wrong-type-argument arg1 arg2 arg3)))))
  75. (define error:bad-range-argument
  76.   (case (scheme-implementation-type)
  77.     ((MITScheme) error:bad-range-argument)
  78.     (else (lambda (arg1 arg2)
  79.         (slib:error 'bad-range-argument arg1 arg2)))))
  80.  
  81. ;;;
  82. ;;; Interface to this package.
  83. ;;;
  84. ;;; ONLY these procedures (and TEST at the end of the file) will be
  85. ;;; (re)defined in your system.
  86. ;;;
  87.  
  88. (define make-wt-tree-type #f)
  89. (define number-wt-type #f)
  90. (define string-wt-type #f)
  91.  
  92. (define make-wt-tree #f)
  93. (define singleton-wt-tree #f)
  94. (define alist->wt-tree #f)
  95. (define wt-tree/empty? #f)
  96. (define wt-tree/size #f)
  97. (define wt-tree/add #f)
  98. (define wt-tree/delete #f)
  99. (define wt-tree/add! #f)
  100. (define wt-tree/delete! #f)
  101. (define wt-tree/member? #f)
  102. (define wt-tree/lookup #f)
  103. (define wt-tree/split< #f)
  104. (define wt-tree/split> #f)
  105. (define wt-tree/union #f)
  106. (define wt-tree/intersection #f)
  107. (define wt-tree/difference #f)
  108. (define wt-tree/subset? #f)
  109. (define wt-tree/set-equal? #f)
  110. (define wt-tree/fold #f)
  111. (define wt-tree/for-each #f)
  112. (define wt-tree/index #f)
  113. (define wt-tree/index-datum #f)
  114. (define wt-tree/index-pair #f)
  115. (define wt-tree/rank #f)
  116. (define wt-tree/min #f)
  117. (define wt-tree/min-datum #f)
  118. (define wt-tree/min-pair #f)
  119. (define wt-tree/delete-min #f)
  120. (define wt-tree/delete-min! #f)
  121.  
  122.  
  123. ;; This LET sets all of the above variables.
  124.  
  125. (let ()
  126.  
  127.   ;; We use the folowing MIT-Scheme operation on fixnums (small
  128.   ;; integers).  R4RS compatible (but less efficient) definitions.
  129.   ;; You should replace these with something that is efficient in your
  130.   ;; system.
  131.  
  132.   (define fix:fixnum? (lambda (x) (and (exact? x) (integer? x))))
  133.   (define fix:+ +)
  134.   (define fix:- -)
  135.   (define fix:< <)
  136.   (define fix:<= <=)
  137.   (define fix:> >)
  138.   (define fix:* *)
  139.  
  140.   ;;  A TREE-TYPE is a collection of those procedures that depend on the
  141.   ;;  ordering relation.
  142.  
  143.   ;; MIT-Scheme structure definition
  144.   ;;(define-structure
  145.   ;;    (tree-type
  146.   ;;     (conc-name tree-type/)
  147.   ;;     (constructor %make-tree-type))
  148.   ;;  (key<?       #F read-only true)
  149.   ;;  (alist->tree #F read-only true)
  150.   ;;  (add         #F read-only true)
  151.   ;;  (insert!     #F read-only true)
  152.   ;;  (delete      #F read-only true)
  153.   ;;  (delete!     #F read-only true)
  154.   ;;  (member?     #F read-only true)
  155.   ;;  (lookup      #F read-only true)
  156.   ;;  (split-lt    #F read-only true)
  157.   ;;  (split-gt    #F read-only true)
  158.   ;;  (union       #F read-only true)
  159.   ;;  (intersection #F read-only true)
  160.   ;;  (difference  #F read-only true)
  161.   ;;  (subset?     #F read-only true)
  162.   ;;  (rank        #F read-only true)
  163.   ;;)
  164.  
  165.   ;; Written out by hand, using vectors:
  166.   ;;
  167.   ;; If possible, you should teach your system to print out something
  168.   ;; like #[tree-type <] instread of the whole vector.
  169.  
  170.   (define tag:tree-type (string->symbol "#[(runtime wttree)tree-type]"))
  171.  
  172.   (define (%make-tree-type key<?       alist->tree 
  173.                            add         insert!     
  174.                            delete      delete!     
  175.                            member?     lookup      
  176.                            split-lt    split-gt    
  177.                            union       intersection 
  178.                            difference  subset?     
  179.                            rank        )
  180.     (vector tag:tree-type
  181.             key<?       alist->tree   add         insert!     
  182.             delete      delete!       member?     lookup      
  183.             split-lt    split-gt      union       intersection 
  184.             difference  subset?       rank        ))
  185.  
  186.   (define (tree-type? tt)
  187.     (and (vector? tt)
  188.          (eq? (vector-ref tt 0) tag:tree-type)))
  189.  
  190.   (define (tree-type/key<?        tt) (vector-ref tt 1))
  191.   (define (tree-type/alist->tree  tt) (vector-ref tt 2))
  192.   (define (tree-type/add          tt) (vector-ref tt 3))
  193.   (define (tree-type/insert!      tt) (vector-ref tt 4))
  194.   (define (tree-type/delete       tt) (vector-ref tt 5))
  195.   (define (tree-type/delete!      tt) (vector-ref tt 6))
  196.   (define (tree-type/member?      tt) (vector-ref tt 7))
  197.   (define (tree-type/lookup       tt) (vector-ref tt 8))
  198.   (define (tree-type/split-lt     tt) (vector-ref tt 9))
  199.   (define (tree-type/split-gt     tt) (vector-ref tt 10))
  200.   (define (tree-type/union        tt) (vector-ref tt 11))
  201.   (define (tree-type/intersection tt) (vector-ref tt 12))
  202.   (define (tree-type/difference   tt) (vector-ref tt 13))
  203.   (define (tree-type/subset?      tt) (vector-ref tt 14))
  204.   (define (tree-type/rank         tt) (vector-ref tt 15))
  205.  
  206.   ;;  User level tree representation.
  207.   ;;
  208.   ;;  WT-TREE is a wrapper for trees of nodes.
  209.   ;;
  210.   ;;MIT-Scheme:
  211.   ;;(define-structure
  212.   ;;    (wt-tree
  213.   ;;     (conc-name tree/)
  214.   ;;     (constructor %make-wt-tree))
  215.   ;;  (type  #F read-only true)
  216.   ;;  (root  #F read-only false))
  217.  
  218.   ;; If possible, you should teach your system to print out something
  219.   ;; like #[wt-tree] instread of the whole vector.
  220.  
  221.   (define tag:wt-tree (string->symbol "#[(runtime wttree)wt-tree]"))
  222.  
  223.   (define (%make-wt-tree type root)
  224.     (vector tag:wt-tree type root))
  225.  
  226.   (define (wt-tree? t)
  227.     (and (vector? t)
  228.          (eq? (vector-ref t 0) tag:wt-tree)))
  229.  
  230.   (define (tree/type t) (vector-ref t 1))
  231.   (define (tree/root t) (vector-ref t 2))
  232.   (define (set-tree/root! t v) (vector-set! t 2 v))
  233.  
  234.   ;;  Nodes are the thing from which the real trees are built.  There are
  235.   ;;  lots of these and the uninquisitibe user will never see them, so
  236.   ;;  they are represented as untagged to save the slot that would be
  237.   ;;  used for tagging structures.
  238.   ;;  In MIT-Scheme these were all DEFINE-INTEGRABLE
  239.  
  240.   (define (make-node k v l r w) (vector w l k r v))
  241.   (define (node/k node) (vector-ref node 2))
  242.   (define (node/v node) (vector-ref node 4))
  243.   (define (node/l node) (vector-ref node 1))
  244.   (define (node/r node) (vector-ref node 3))
  245.   (define (node/w node) (vector-ref node 0))
  246.  
  247.   (define empty  'empty)
  248.   (define (empty? x) (eq? x 'empty))
  249.  
  250.   (define (node/size node)
  251.     (if (empty? node) 0  (node/w node)))
  252.  
  253.   (define (node/singleton k v) (make-node k v empty empty 1))
  254.  
  255.   (define (with-n-node node receiver)
  256.     (receiver (node/k node) (node/v node) (node/l node) (node/r node)))
  257.  
  258.   ;;
  259.   ;;  Constructors for building node trees of various complexity
  260.   ;;
  261.  
  262.   (define (n-join k v l r)
  263.     (make-node k v l r (fix:+ 1 (fix:+ (node/size l) (node/size r)))))
  264.  
  265.   (define (single-l a.k a.v x r)
  266.     (with-n-node r
  267.       (lambda (b.k b.v y z) (n-join b.k b.v (n-join a.k a.v x y) z))))
  268.  
  269.   (define (double-l a.k a.v x r)
  270.     (with-n-node r
  271.       (lambda (c.k c.v r.l z)
  272.         (with-n-node r.l
  273.           (lambda (b.k b.v y1 y2)
  274.             (n-join b.k b.v
  275.                     (n-join a.k a.v x y1)
  276.                     (n-join c.k c.v y2 z)))))))
  277.  
  278.   (define (single-r b.k b.v l z)
  279.     (with-n-node l
  280.       (lambda (a.k a.v x y) (n-join a.k a.v x (n-join b.k b.v y z)))))
  281.  
  282.   (define (double-r c.k c.v l z)
  283.     (with-n-node l
  284.       (lambda (a.k a.v x l.r)
  285.         (with-n-node l.r
  286.           (lambda (b.k b.v y1 y2)
  287.             (n-join b.k b.v
  288.                     (n-join a.k a.v x y1)
  289.                     (n-join c.k c.v y2 z)))))))
  290.  
  291.   ;; (define-integrable wt-tree-ratio 5)
  292.   (define wt-tree-ratio 5)
  293.  
  294.   (define (t-join k v l r)
  295.     (define (simple-join) (n-join k v l r))
  296.     (let ((l.n  (node/size l))
  297.           (r.n  (node/size r)))
  298.       (cond ((fix:< (fix:+ l.n r.n) 2)   (simple-join))
  299.             ((fix:> r.n (fix:* wt-tree-ratio l.n))
  300.              ;; right is too big
  301.              (let ((r.l.n  (node/size (node/l r)))
  302.                    (r.r.n  (node/size (node/r r))))
  303.                (if (fix:< r.l.n r.r.n)
  304.                    (single-l k v l r)
  305.                    (double-l k v l r))))
  306.             ((fix:> l.n (fix:* wt-tree-ratio r.n))
  307.              ;; left is too big
  308.              (let ((l.l.n  (node/size (node/l l)))
  309.                    (l.r.n  (node/size (node/r l))))
  310.                (if (fix:< l.r.n l.l.n)
  311.                    (single-r k v l r)
  312.                    (double-r k v l r))))
  313.             (else
  314.              (simple-join)))))
  315.   ;;
  316.   ;;  Node tree procedures that are independent of key<?
  317.   ;;
  318.  
  319.   (define (node/min node)
  320.     (cond  ((empty? node)          (error:empty 'min))
  321.            ((empty? (node/l node)) node)
  322.            (else                   (node/min (node/l node)))))
  323.  
  324.   (define (node/delmin node)
  325.     (cond ((empty? node)           (error:empty 'delmin))
  326.           ((empty? (node/l node))  (node/r node))
  327.           (else   (t-join (node/k node) (node/v node)
  328.                           (node/delmin (node/l node)) (node/r node)))))
  329.  
  330.   (define (node/concat2 node1 node2)
  331.     (cond ((empty? node1)   node2)
  332.           ((empty? node2)   node1)
  333.           (else
  334.            (let ((min-node (node/min node2)))
  335.              (t-join (node/k min-node) (node/v min-node)
  336.                      node1 (node/delmin node2))))))
  337.  
  338.   (define (node/inorder-fold procedure base node)
  339.     (define (fold base node)
  340.       (if (empty? node)
  341.           base
  342.           (with-n-node node
  343.             (lambda (k v l r)
  344.               (fold (procedure k v (fold base r)) l)))))
  345.     (fold base node))
  346.  
  347.   (define (node/for-each procedure node)
  348.     (if (not (empty? node))
  349.         (with-n-node node
  350.           (lambda (k v l r)
  351.             (node/for-each procedure l)
  352.             (procedure k v)
  353.             (node/for-each procedure r)))))
  354.  
  355.   (define (node/height node)
  356.     (if (empty? node)
  357.         0
  358.         (+ 1 (max (node/height (node/l node))
  359.                   (node/height (node/r node))))))
  360.  
  361.   (define (node/index node index)
  362.     (define (loop node index)
  363.       (let ((size.l  (node/size (node/l node))))
  364.         (cond ((fix:< index size.l)  (loop (node/l node) index))
  365.               ((fix:> index size.l)  (loop (node/r node)
  366.                                            (fix:- index (fix:+ 1 size.l))))
  367.               (else                  node))))
  368.     (let ((bound  (node/size node)))
  369.       (if (or (< index 0)
  370.               (>= index bound)
  371.               (not (fix:fixnum? index)))
  372.           (error:bad-range-argument index 'node/index)
  373.           (loop node index))))
  374.  
  375.   (define (error:empty owner)
  376.     (error "Operation requires non-empty tree:" owner))
  377.  
  378.  
  379.   (define (local:make-wt-tree-type key<?)
  380.  
  381.     ;; MIT-Scheme definitions:
  382.     ;;(declare (integrate key<?))
  383.     ;;(define-integrable (key>? x y)  (key<? y x))
  384.  
  385.     (define (key>? x y)  (key<? y x))
  386.  
  387.     (define (node/find k node)
  388.       ;; Returns either the node or #f.
  389.       ;; Loop takes D comparisons where D is the depth of the tree
  390.       ;; rather than the traditional compare-low, compare-high which
  391.       ;; takes on average 1.5(D-1) comparisons
  392.       (define (loop this best)
  393.         (cond ((empty? this)  best)
  394.               ((key<? k (node/k this))   (loop (node/l this) best))
  395.               (else (loop (node/r this) this))))
  396.       (let ((best (loop node #f)))
  397.         (cond ((not best)               #f)
  398.               ((key<? (node/k best) k)  #f)
  399.               (else                     best))))
  400.  
  401.     (define (node/rank k node rank)
  402.       (cond ((empty? node)             #f)
  403.             ((key<? k (node/k node))  (node/rank k (node/l node) rank))
  404.             ((key>? k (node/k node))  
  405.              (node/rank k (node/r node)
  406.                         (fix:+ 1 (fix:+ rank (node/size (node/l node))))))
  407.             (else                     (fix:+ rank (node/size (node/l node))))))
  408.     
  409.     (define (node/add node k v)
  410.       (if (empty? node)
  411.           (node/singleton k v)
  412.           (with-n-node node
  413.             (lambda (key val l r)
  414.               (cond ((key<? k key)   (t-join key val (node/add l k v) r))
  415.                     ((key<? key k)   (t-join key val l (node/add r k v)))
  416.                     (else            (n-join key v   l r)))))))
  417.  
  418.     (define (node/delete x node)
  419.       (if (empty? node)
  420.           empty
  421.           (with-n-node node
  422.             (lambda (key val l r)
  423.               (cond ((key<? x key)   (t-join key val (node/delete x l) r))
  424.                     ((key<? key x)   (t-join key val l (node/delete x r)))
  425.                     (else            (node/concat2 l r)))))))
  426.  
  427.     (define (node/concat tree1 tree2)
  428.       (cond ((empty? tree1)  tree2)
  429.             ((empty? tree2)  tree1)
  430.             (else
  431.              (let ((min-node (node/min tree2)))
  432.                (node/concat3 (node/k min-node) (node/v min-node) tree1
  433.                              (node/delmin tree2))))))
  434.  
  435.     (define (node/concat3 k v l r)
  436.       (cond ((empty? l)   (node/add r k v))
  437.             ((empty? r)   (node/add l k v))
  438.             (else
  439.              (let ((n1  (node/size l))
  440.                    (n2  (node/size r)))
  441.                (cond ((fix:< (fix:* wt-tree-ratio n1) n2)
  442.                       (with-n-node r
  443.                         (lambda (k2 v2 l2 r2)
  444.                           (t-join k2 v2 (node/concat3 k v l l2) r2))))
  445.                      ((fix:< (fix:* wt-tree-ratio n2) n1)
  446.                       (with-n-node l
  447.                         (lambda (k1 v1 l1 r1)
  448.                           (t-join k1 v1 l1 (node/concat3 k v r1 r)))))
  449.                      (else
  450.                       (n-join k v l r)))))))
  451.  
  452.     (define (node/split-lt node x)
  453.       (cond ((empty? node)  empty)
  454.             ((key<? x (node/k node))
  455.              (node/split-lt (node/l node) x))
  456.             ((key<? (node/k node) x)
  457.              (node/concat3 (node/k node) (node/v node) (node/l node)
  458.                            (node/split-lt (node/r node) x)))
  459.             (else (node/l node))))
  460.  
  461.     (define (node/split-gt node x)
  462.       (cond ((empty? node)  empty)
  463.             ((key<? (node/k node) x)
  464.              (node/split-gt (node/r node) x))
  465.             ((key<? x (node/k node))
  466.              (node/concat3 (node/k node) (node/v node) 
  467.                            (node/split-gt (node/l node) x) (node/r node)))
  468.             (else (node/r node))))
  469.  
  470.     (define (node/union tree1 tree2)
  471.       (cond ((empty? tree1)  tree2)
  472.             ((empty? tree2)  tree1)
  473.             (else
  474.              (with-n-node tree2
  475.                (lambda (ak av l r)
  476.                  (let ((l1  (node/split-lt tree1 ak))
  477.                        (r1  (node/split-gt tree1 ak)))
  478.                    (node/concat3 ak av (node/union l1 l) (node/union r1 r))))))))
  479.  
  480.     (define (node/difference tree1 tree2)
  481.       (cond ((empty? tree1)   empty)
  482.             ((empty? tree2)   tree1)
  483.             (else
  484.              (with-n-node tree2
  485.                (lambda (ak av l r)
  486.                  (let ((l1  (node/split-lt tree1 ak))
  487.                        (r1  (node/split-gt tree1 ak)))
  488.                    av
  489.                    (node/concat (node/difference l1 l)
  490.                                 (node/difference r1 r))))))))
  491.  
  492.     (define (node/intersection tree1 tree2)
  493.       (cond ((empty? tree1)   empty)
  494.             ((empty? tree2)   empty)
  495.             (else
  496.              (with-n-node tree2
  497.                (lambda (ak av l r)
  498.                  (let ((l1  (node/split-lt tree1 ak))
  499.                        (r1  (node/split-gt tree1 ak)))
  500.                    (if (node/find ak tree1)
  501.                        (node/concat3 ak av (node/intersection l1 l)
  502.                                      (node/intersection r1 r))
  503.                        (node/concat (node/intersection l1 l)
  504.                                     (node/intersection r1 r)))))))))
  505.  
  506.     (define (node/subset? tree1 tree2)
  507.       (or (empty? tree1)
  508.           (and (fix:<= (node/size tree1) (node/size tree2))
  509.                (with-n-node tree1
  510.                  (lambda (k v l r)
  511.                    v
  512.                    (cond ((key<? k (node/k tree2))
  513.                           (and (node/subset? l (node/l tree2))
  514.                                (node/find k tree2)
  515.                                (node/subset? r tree2)))
  516.                          ((key>? k (node/k tree2))
  517.                           (and (node/subset? r (node/r tree2))
  518.                                (node/find k tree2)
  519.                                (node/subset? l tree2)))
  520.                          (else
  521.                           (and (node/subset? l (node/l tree2))
  522.                                (node/subset? r (node/r tree2))))))))))
  523.  
  524.  
  525.     ;;; Tree interface: stripping off or injecting the tree types
  526.  
  527.     (define (tree/map-add tree k v)
  528.       (%make-wt-tree (tree/type tree)
  529.                      (node/add (tree/root tree) k v)))
  530.  
  531.     (define (tree/insert! tree k v)
  532.       (set-tree/root! tree (node/add (tree/root tree) k v)))
  533.  
  534.     (define (tree/delete tree k)
  535.       (%make-wt-tree (tree/type tree)
  536.                      (node/delete k (tree/root tree))))
  537.  
  538.     (define (tree/delete! tree k)
  539.       (set-tree/root! tree (node/delete k (tree/root tree))))
  540.  
  541.     (define (tree/split-lt tree key)
  542.       (%make-wt-tree (tree/type tree)
  543.                      (node/split-lt (tree/root tree) key)))
  544.  
  545.     (define (tree/split-gt tree key)
  546.       (%make-wt-tree (tree/type tree)
  547.                      (node/split-gt (tree/root tree) key)))
  548.  
  549.     (define (tree/union tree1 tree2)
  550.       (%make-wt-tree (tree/type tree1)
  551.                      (node/union (tree/root tree1) (tree/root tree2))))
  552.  
  553.     (define (tree/intersection tree1 tree2)
  554.       (%make-wt-tree (tree/type tree1)
  555.                      (node/intersection (tree/root tree1) (tree/root tree2))))
  556.  
  557.     (define (tree/difference tree1 tree2)
  558.       (%make-wt-tree (tree/type tree1)
  559.                      (node/difference (tree/root tree1) (tree/root tree2))))
  560.  
  561.     (define (tree/subset? tree1 tree2)
  562.       (node/subset? (tree/root tree1) (tree/root tree2)))
  563.  
  564.     (define (alist->tree alist)
  565.       (define (loop alist node)
  566.         (cond ((null? alist)  node)
  567.               ((pair? alist)  (loop (cdr alist)
  568.                                     (node/add node (caar alist) (cdar alist))))
  569.               (else           
  570.                (error:wrong-type-argument alist "alist" 'alist->tree))))
  571.       (%make-wt-tree my-type (loop alist empty)))
  572.  
  573.     (define (tree/get tree key default)
  574.       (let ((node  (node/find key (tree/root tree))))
  575.         (if node
  576.             (node/v node)
  577.             default)))
  578.  
  579.     (define (tree/rank tree key)  (node/rank key (tree/root tree) 0))
  580.  
  581.     (define (tree/member? key tree)
  582.       (and (node/find key (tree/root tree))
  583.            #t))
  584.  
  585.     (define my-type #F)
  586.  
  587.     (set! my-type
  588.           (%make-tree-type
  589.            key<?                        ;  key<?
  590.            alist->tree                  ;  alist->tree
  591.            tree/map-add                 ;  add
  592.            tree/insert!                 ;  insert!
  593.            tree/delete                  ;  delete
  594.            tree/delete!                 ;  delete!
  595.            tree/member?                 ;  member?
  596.            tree/get                     ;  lookup
  597.            tree/split-lt                ;  split-lt
  598.            tree/split-gt                ;  split-gt
  599.            tree/union                   ;  union
  600.            tree/intersection            ;  intersection
  601.            tree/difference              ;  difference
  602.            tree/subset?                 ;  subset?
  603.            tree/rank                    ;  rank
  604.            ))
  605.  
  606.     my-type)
  607.  
  608.   (define (guarantee-tree tree procedure)
  609.     (if (not (wt-tree? tree))
  610.         (error:wrong-type-argument tree "weight-balanced tree" procedure)))
  611.  
  612.   (define (guarantee-tree-type type procedure)
  613.     (if (not (tree-type? type))
  614.         (error:wrong-type-argument type "weight-balanced tree type" procedure)))
  615.  
  616.   (define (guarantee-compatible-trees tree1 tree2 procedure)
  617.     (guarantee-tree tree1 procedure)
  618.     (guarantee-tree tree2 procedure)
  619.     (if (not (eq? (tree/type tree1) (tree/type tree2)))
  620.         (error "The trees" tree1 'and tree2 'have 'incompatible 'types
  621.                (tree/type tree1) 'and (tree/type tree2))))
  622.  
  623. ;;;______________________________________________________________________
  624. ;;;
  625. ;;;  Export interface
  626. ;;;
  627.   (set! make-wt-tree-type local:make-wt-tree-type)
  628.  
  629.   (set! make-wt-tree
  630.         (lambda (tree-type)
  631.           (%make-wt-tree tree-type empty)))
  632.  
  633.   (set! singleton-wt-tree
  634.         (lambda (type key value)
  635.           (guarantee-tree-type type 'singleton-wt-tree)
  636.           (%make-wt-tree type (node/singleton key value))))
  637.  
  638.   (set! alist->wt-tree
  639.         (lambda (type alist)
  640.           (guarantee-tree-type type 'alist->wt-tree)
  641.           ((tree-type/alist->tree type) alist)))
  642.  
  643.   (set! wt-tree/empty?
  644.         (lambda (tree)
  645.           (guarantee-tree tree 'wt-tree/empty?)
  646.           (empty? (tree/root tree))))
  647.  
  648.   (set! wt-tree/size
  649.         (lambda (tree)
  650.           (guarantee-tree tree 'wt-tree/size)
  651.           (node/size (tree/root tree))))
  652.  
  653.   (set! wt-tree/add
  654.         (lambda (tree key datum)
  655.           (guarantee-tree tree 'wt-tree/add)
  656.           ((tree-type/add (tree/type tree)) tree key datum)))
  657.  
  658.   (set! wt-tree/delete
  659.         (lambda (tree key)
  660.           (guarantee-tree tree 'wt-tree/delete)
  661.           ((tree-type/delete (tree/type tree)) tree key)))
  662.  
  663.   (set! wt-tree/add!
  664.         (lambda (tree key datum)
  665.           (guarantee-tree tree 'wt-tree/add!)
  666.           ((tree-type/insert! (tree/type tree)) tree key datum)))
  667.  
  668.   (set! wt-tree/delete!
  669.         (lambda (tree key)
  670.           (guarantee-tree tree 'wt-tree/delete!)
  671.           ((tree-type/delete! (tree/type tree)) tree key)))
  672.  
  673.   (set! wt-tree/member?
  674.         (lambda (key tree)
  675.           (guarantee-tree tree 'wt-tree/member?)
  676.           ((tree-type/member? (tree/type tree)) key tree)))
  677.  
  678.   (set! wt-tree/lookup
  679.         (lambda (tree key default)
  680.           (guarantee-tree tree 'wt-tree/lookup)
  681.           ((tree-type/lookup (tree/type tree)) tree key default)))
  682.  
  683.   (set! wt-tree/split<
  684.         (lambda (tree key)
  685.           (guarantee-tree tree 'wt-tree/split<)
  686.           ((tree-type/split-lt (tree/type tree)) tree key)))
  687.  
  688.   (set! wt-tree/split>
  689.         (lambda (tree key)
  690.           (guarantee-tree tree 'wt-tree/split>)
  691.           ((tree-type/split-gt (tree/type tree)) tree key)))
  692.  
  693.   (set! wt-tree/union
  694.         (lambda (tree1 tree2)
  695.           (guarantee-compatible-trees tree1 tree2 'wt-tree/union)
  696.           ((tree-type/union (tree/type tree1)) tree1 tree2)))
  697.  
  698.   (set! wt-tree/intersection
  699.         (lambda (tree1 tree2)
  700.           (guarantee-compatible-trees tree1 tree2 'wt-tree/intersection)
  701.           ((tree-type/intersection (tree/type tree1)) tree1 tree2)))
  702.  
  703.   (set! wt-tree/difference
  704.         (lambda (tree1 tree2)
  705.           (guarantee-compatible-trees tree1 tree2 'wt-tree/difference)
  706.           ((tree-type/difference (tree/type tree1)) tree1 tree2)))
  707.  
  708.   (set! wt-tree/subset?
  709.         (lambda (tree1 tree2)
  710.           (guarantee-compatible-trees tree1 tree2 'wt-tree/subset?)
  711.           ((tree-type/subset? (tree/type tree1)) tree1 tree2)))
  712.  
  713.   (set! wt-tree/set-equal?
  714.         (lambda (tree1 tree2)
  715.           (and (wt-tree/subset? tree1 tree2)
  716.                (wt-tree/subset? tree2 tree1))))
  717.  
  718.   (set! wt-tree/fold
  719.         (lambda (combiner-key-datum-result init tree)
  720.           (guarantee-tree tree 'wt-tree/fold)
  721.           (node/inorder-fold combiner-key-datum-result
  722.                              init
  723.                              (tree/root tree))))
  724.  
  725.   (set! wt-tree/for-each
  726.         (lambda (action-key-datum tree)
  727.           (guarantee-tree tree 'wt-tree/for-each)
  728.           (node/for-each action-key-datum (tree/root tree))))
  729.  
  730.   (set! wt-tree/index
  731.         (lambda (tree index)
  732.           (guarantee-tree tree 'wt-tree/index)
  733.           (let ((node  (node/index (tree/root tree) index)))
  734.             (and node (node/k node)))))
  735.  
  736.   (set! wt-tree/index-datum
  737.         (lambda (tree index)
  738.           (guarantee-tree tree 'wt-tree/index-datum)
  739.           (let ((node  (node/index (tree/root tree) index)))
  740.             (and node (node/v node)))))
  741.  
  742.   (set! wt-tree/index-pair
  743.         (lambda (tree index)
  744.           (guarantee-tree tree 'wt-tree/index-pair)
  745.           (let ((node  (node/index (tree/root tree) index)))
  746.             (and node (cons (node/k node) (node/v node))))))
  747.  
  748.   (set! wt-tree/rank
  749.         (lambda (tree key)
  750.           (guarantee-tree tree 'wt-tree/rank)
  751.           ((tree-type/rank (tree/type tree)) tree key)))
  752.  
  753.   (set! wt-tree/min
  754.         (lambda (tree)
  755.           (guarantee-tree tree 'wt-tree/min)
  756.           (node/k (node/min (tree/root tree)))))
  757.  
  758.   (set! wt-tree/min-datum
  759.         (lambda (tree)
  760.           (guarantee-tree tree 'wt-tree/min-datum)
  761.           (node/v (node/min (tree/root tree)))))
  762.  
  763.   (set! wt-tree/min-pair
  764.         (lambda (tree)
  765.           (guarantee-tree tree 'wt-tree/min-pair)
  766.           (let ((node  (node/min (tree/root tree))))
  767.             (cons (node/k node) (node/v node)))))
  768.  
  769.   (set! wt-tree/delete-min
  770.         (lambda (tree)
  771.           (guarantee-tree tree 'wt-tree/delete-min)
  772.           (%make-wt-tree (tree/type tree)
  773.                          (node/delmin (tree/root tree)))))
  774.  
  775.   (set! wt-tree/delete-min!
  776.         (lambda (tree)
  777.           (guarantee-tree tree 'wt-tree/delete-min!)
  778.           (set-tree/root! tree (node/delmin (tree/root tree)))))
  779.  
  780.   ;; < is a lexpr. Many compilers can open-code < so the lambda is faster
  781.   ;; than passing <.
  782.   (set! number-wt-type (local:make-wt-tree-type  (lambda (u v) (< u v))))
  783.   (set! string-wt-type (local:make-wt-tree-type  string<?))
  784.  
  785.   'done)
  786.  
  787. ;;; Local Variables:
  788. ;;; eval: (put 'with-n-node 'scheme-indent-function 1)
  789. ;;; eval: (put 'with-n-node 'scheme-indent-hook 1)
  790. ;;; End:
  791.